perm filename MAPS1.SAI[SYS,HE] blob
sn#106016 filedate 1974-06-07 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00024 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 MAPS1 - programs for the parsing of the scene.
C00007 00003 _ external and forward procedures - LCRV, SETBYTE
C00009 00004 _ DTRCE, LINDL, QTRCE
C00011 00005 _ MLCR, REVIVE, UPPDAL
C00013 00006 _ DISPLY, DATCHK
C00015 00007 _ DATCHK cont
C00018 00008 _ UNTST, BREAK
C00021 00009 _ CLUPSC
C00024 00010 _ CLUPSC cont
C00025 00011 _ FUSABL
C00029 00012 _ LFDIF
C00034 00013 _ GARCOL
C00037 00014 _ GARCOL cont
C00040 00015 _ MAP (VCRKEY)
C00043 00016 _ MAP cont
C00045 00017 _ CLEANUP
C00048 00018 _ PARSE
C00050 00019 _ PARSE cont
C00053 00020 _ PARSE cont
C00056 00021 _ PARSE cont.
C00058 00022 _ PARSE cont
C00060 00023 _ PARSE cont
C00063 00024 _ PARSE cont
C00065 ENDMK
C⊗;
COMMENT MAPS1 - programs for the parsing of the scene.;
ENTRY LCRV,LCRL,DTRCE,LINDL,QTRCE,MLCR,REVIVE,CLUPSC,
UPPDAL,FUSABL,LFDIF,MAP,PARSE;
BEGIN "MAPS1"
DEFINE QC(I)="&"" I=""&CVS(I)",
QCO(I)="&"" I=""&CVOS(I)",
QCR(R)="&"" R=""&CVF(R)",
NOTHING="",
CL="'15&'12",
QSCOR="&"" SCORE=""&CVS(CONF)&""/""&CVS(PARTS[CMPIND+1] LAND 2)
&""/""&CVS(LDB(BYT2+1))",
BL="'40",
QENP="EXTERNAL PROCEDURE",
QS="STRING",
QESP="EXTERNAL SIMPLE STRING PROCEDURE",
QI="INTEGER",
QR="REAL",
QRI="REFERENCE INTEGER",
QRR="REFERENCE REAL",
QEP="EXTERNAL SIMPLE PROCEDURE",
QEIP="EXTERNAL SIMPLE INTEGER PROCEDURE",
QERP="EXTERNAL SIMPLE REAL PROCEDURE",
QFOP="FORWARD INTERNAL SIMPLE PROCEDURE",
QFOIP="FORWARD INTERNAL SIMPLE INTEGER PROCEDURE",
QFORP="FORWARD INTERNAL SIMPLE REAL PROCEDURE",
_="COMMENT",
LOOP(I,J,K,L)="FOR I←J STEP L UNTIL K DO",
SQTRC="IF DTRACE∨MAPTRC LAND '10012000 THEN QTRCE",
QTRC="IF ¬(MAPTRC LAND '10000000)∧(DTRACE∨MAPTRC LAND '10012000)
THEN QTRCE",
DTRC="IF ¬(MAPTRC LAND '10000000)∧(DTRACE∨MAPTRC LAND '10010000)
THEN DTRCE",
BELCRE(I)="LVNEXT(I,-1)",
FRECOR="500",
SAFEX="SAFE";
INTEGER IA,DCHAN,TC,BSTBYT,DELFLG,LNKFLG;
INTERNAL INTEGER PROT,PLIN,PVER,AD0,LNCS1,LNCS2,RAYS,ICH,CMPIND,
BRCH,EOF,DTRACE,KMP,MDCTR,DISW,FLMIND,FTSW,LFDBT,BESTMP,NPRS,
LNCRE0,FRESIZE,BYTE,BYT1,BYT2,BYT3,CURMAP;
EXTERNAL INTEGER NOEPA,NOL,MAXNOL,MAXNOV,LNCRE1,LNCRE2,
PFTOT,MODIF,PLFTOT,MAXPLS,MAXPVS,MAPTRC,SCO,CONF,CMPL;
EXTERNAL REAL RWIC,RMAP;
SAFEX EXTERNAL INTEGER ARRAY DICH[0:1],LCREDE,LFEAT,LVERCO,LINK,
LVERSI,PLINES,PVERTS,PPTRL,PLINE,PLINE2,PFPRO,PFEAT,
LEDG1,LEDG2,LVER,CFEAT[1:1],PFPTR[0:1];
SAFEX EXTERNAL REAL ARRAY XVCOR,YVCOR,XLCOR,YLCOR,CXL,CYL,CCL,RLEN[1:1];
SAFEX EXTERNAL STRING ARRAY PNAME[1:1];
_ external and forward procedures - LCRV, SETBYTE;
QEP LINDEL(QI I,J);
QEIP BITS(QI I,J,K);
QEIP MAPCONV(QS CODES);
QEIP INREK(QR X,Y);
QEP UPPDAT;
QEP FTEX;
QENP XREFC(QI I);
QEP UNXREF;
QEIP LACT(QI I);
QERP ANGLIN(QI I,J);
QEIP LVOPP(QI I);
QEIP MAX0(QI I,J);
QEIP KARN(QR X1,Y1,X2,Y2,X3,Y3,X4,Y4; QI IC);
QEP REKOP(QR X1,Y1,X2,Y2,WI; QRR RL);
QEP WEIGHV(QI I; QRR X,Y,WE);
QEIP MAPREC;
QEP PRECAL;
QEP CALC;
QEIP LVNEXT(QI I,J);
QEP REGREF(INTEGER I);
QEIP MSCVCO(QI ISV, ICV, LADD);
QEIP NEXVER;
QEIP LCRL(QI L);
_ return LCREDE entry for s.v. SV (sign and low 4 octal digits only);
INTERNAL SIMPLE INTEGER PROCEDURE LCRV(INTEGER SV);
RETURN(LCREDE[(SV+1)%2] LAND '400000007777);
_ set up byte pointers for PARTS array - current block;
INTERNAL PROCEDURE SETBYTE(INTEGER PTR);
BEGIN "SETB"
EXTERNAL SAFEX INTEGER ARRAY PARTS[1:FRECOR];
BYT1←BYTE←POINT(12,PARTS[PTR],-1);
IBP(BYT1);
BYT2←BYT1;
IBP(BYT2);
BYT3←BYT2;
IBP(BYT3);
END "SETB";
_ DTRCE, LINDL, QTRCE;
_ Produces trace output on file "PARSE.TRC" if MAPTRC bit 12 is set.;
INTERNAL SIMPLE PROCEDURE DTRCE(STRING S);
BEGIN "DTRC"
IF DTRACE∧DCHAN=-1∨¬DTRACE∧(DTRACE←MAPTRC LAND '10010000) THEN
BEGIN
OPEN(DCHAN←GETCHAN,"DSK",0,0,2,100,BRCH,EOF);
ENTER(DCHAN,"PARS"&CVS(NPRS←NPRS+1)&".TRC",IA)
END;
IF DTRACE∧¬(DTRACE←MAPTRC LAND '10010000) THEN
BEGIN CLOSE(DCHAN); DCHAN←-1 END;
TC←TC+1;
IF MAPTRC LAND '40000 THEN OUTSTR('11&CVS(TC));
IF DTRACE THEN OUT(DCHAN,CL&CVS(TC)&'11&S);
END "DTRC";
_ line deletion with tracing;
INTERNAL SIMPLE PROCEDURE LINDL(INTEGER L,I);
BEGIN DISW←1; DTRC("LINDEL:"QC(L)); LINDEL(L,I) END;
_ Produces trace typeouts, and pauses if correct bit is set in MAPTRC.
Also puts out trace on DSK-file "PARSE.TRC" if bit 12 of MAPTRC is set.;
INTERNAL SIMPLE PROCEDURE QTRCE(STRING S);
BEGIN "QTRC"
IF DTRACE∨MAPTRC LAND '10010000 THEN DTRCE(S);
IF MAPTRC LAND '2000 THEN
BEGIN
OUTSTR(CL&S);
IF MAPTRC LAND '4000 THEN
BEGIN
WHILE (ICH←INCHRW)≠":"∧ICH≠"←" DO NOTHING;
IF ICH="←" THEN MAPTRC←MAPCONV(INSTR(":"))
END
END;
END "QTRC";
_ MLCR, REVIVE, UPPDAL;
_ Pushes LC onto the LCREDE-stack for line LN.;
INTERNAL SIMPLE PROCEDURE MLCR(INTEGER LN,LC);
BEGIN "MLCR"
DISW←1;
DTRC("MLCR: "QC(LN)QC(LC));
IF LN THEN LCREDE[LN]←LCREDE[LN] LSH 12 LOR LC
END "MLCR";
_ Pops LCREDE off top of stack, leaving next-to-newest value.;
INTERNAL SIMPLE PROCEDURE REVIVE(INTEGER LN);
BEGIN "REVIVE"
DISW←1;
DTRC("REVIVE: "QC(LN));
IF LN THEN LCREDE[LN]←LCREDE[LN] LSH -12
END "REVIVE";
_ Updates line-display, and waits for a ":" iff SW is on.;
INTERNAL SIMPLE PROCEDURE UPPDAL(INTEGER SW);
BEGIN "UPPDAL"
IF ¬DISW THEN RETURN ELSE DISW←0;
IF SW>0 THEN
BEGIN
LNCRE1←LNCRE0;
DICH[4]←DICH[5]←DICH[6]←1;
UPPDAT;
IF MAPTRC LAND '100000 THEN BEGIN PRECAL; CALC END;
OUTSTR(" D ");
LNCRE1←LNCS1
END;
IF SW THEN
BEGIN
WHILE (ICH←INCHRW)≠":"∧ICH≠"←" DO NOTHING;
IF ICH="←" THEN MAPTRC←MAPCONV(INSTR(":"))
END
END "UPPDAL";
_ DISPLY, DATCHK;
_ display lines from mapping data structure. BYTE is byte pointer
and COUNT is number of lines. Displays only existing lines.
BYTE is updated to point to end of lines on exit;
SIMPLE PROCEDURE DISPLY(INTEGER COUNT; REFERENCE INTEGER BYTE);
BEGIN INTEGER I, J, K;
J ← BYTE;
DISW ← 1;
FOR I←1 STEP 1 UNTIL COUNT DO
BEGIN "DISA"
K ← ILDB(J);
IF LCRL(K)>0 THEN MLCR(K,1006);
END "DISA";
LNCRE1 ← LNCRE2 ← 1006;
DICH[4] ← DICH[5] ← DICH[6] ← 1;
UPPDAT;
LNCRE1 ← LNCS1;
LNCRE2 ← LNCS2;
J ← BYTE;
FOR I←1 STEP 1 UNTIL COUNT DO
BEGIN "DISB"
K ← ILDB(J);
IF LCRL(K)>0 THEN REVIVE(K);
END "DISB";
BYTE ← J;
END;
_ Debugging routine to display and error-check mapping data structure;
INTERNAL PROCEDURE DATCHK(STRING LOC);
BEGIN
EXTERNAL SAFEX INTEGER ARRAY PARTS[1:FRECOR];
SAFEX INTEGER ARRAY FLAG[1:MAXNOL];
INTEGER BYTE, BT, BEST, LENG, PRT, ILEN, DLEN, SCOR, BIT, I, J,
OBJ, U, V, OLD;
BOOLEAN DPY, DEL;
GETFORMAT(U,V);
SETFORMAT(0,0);
OUTSTR("DATA STRUCTURE CHECK - "&LOC&CL&"DISPLAY?");
DPY ← INCHWL = "Y";
BT ← BYTE ← POINT(12,PARTS[1],-1);
OLD ← 1;
OBJ ← 0;
BEST ← (BSTBYT LAND '777777) - LOCATION(PARTS[1]);
_ DATCHK cont;
WHILE PARTS[OLD] DO
BEGIN "CHECK" INTEGER BA;
OBJ ← OBJ+1;
LENG ← ILDB(BT);
ILEN ← ILDB(BT);
DLEN ← ILDB(BT);
PRT ← ILDB(BT);
SCOR ← ILDB(BT);
BIT ← ILDB(BT);
BA ← BT ← BT+1;
DEL ← BIT LAND 1;
IF ¬DEL THEN FOR I←1 STEP 1 UNTIL ILEN DO
BEGIN "DATA" INTEGER K;
J ← ILDB(BT);
K ← LCRL(J);
IF (K=1002∨K=1004∨(K>2000∧¬(K LAND 1)))∧FLAG[J] THEN
BEGIN "DATB"
OUTSTR("LINE "&CVS(J)&" IN OBJECT "&CVS(OBJ)&
" ALSO IN OBJECT "&CVS(FLAG[J])&CL);
INCHWL;
END "DATB";
IF LCRL(J)<0 THEN
BEGIN "DATC"
OUTSTR("LINE "&CVS(J)&" IN OBJECT "&CVS(OBJ)&
" ALREADY DELETED"&CL);
INCHWL;
END "DATC" ELSE FLAG[J] ← OBJ;
END "DATA";
BT ← BA;
IF DPY THEN
BEGIN "DATD"
IF ¬DEL THEN DISPLY(ILEN,BT);
OUTSTR("OBJECT="&CVS(OBJ)&" INDEX="&CVS(OLD)&
" PROT="&PNAME[PRT]&" SCOR="&CVS(SCOR)&
" - "&(IF DEL THEN "DELETED" ELSE
IF BIT LAND 2 THEN "COMPLETED" ELSE
IF BIT LAND 4 THEN "TO DELETE" ELSE
NULL)&(IF BEST=OLD THEN " - BEST" ELSE NULL)&CL);
I ← INCHWL;
IF ¬DEL∧I="D" THEN
BEGIN "DATE"
DISPLY(DLEN,BT);
INCHWL;
END "DATE";
END "DATD";
OLD ← OLD + LENG;
BT ← BYTE ← BYTE + LENG;
END "CHECK";
SETFORMAT(U,V);
END;
_ UNTST, BREAK;
_ tests cv for active and inactive lines. Returns zero if all lines
connected to cv are active or inactive. If some lines of each type
are connected, it returns the total number of lines;
SIMPLE INTEGER PROCEDURE UNTST(INTEGER CV);
BEGIN "UNTST"
INTEGER L, FL, FLG, N, RET;
FL ← L ← LVERSI[CV];
IF FL<0∨LVER[FL]=L THEN RETURN(0);
FLG ← LACT((FL+1) DIV 2);
RET ← 0;
N ← 1;
WHILE (L←LVER[L])≠FL DO
BEGIN "UNA"
IF LACT((L+1) DIV 2) XOR FLG THEN RET←-1;
N ← N+1;
END "UNA";
RETURN(IF RET THEN N ELSE 0);
END "UNTST";
_ Breaks cv into two cv's, if necessary, and relinks them to seperate
active and inactive lines. New cv contains all inactive lines;
SIMPLE PROCEDURE BREAK(INTEGER CV; SAFEX INTEGER ARRAY FLAGS);
BEGIN "BREAK"
INTEGER LN, L, NCV, I, LAD, N, LIN, CRE;
N←UNTST(CV);
IF ¬N THEN RETURN;
L ← LVERSI[CV];
NCV ← 0;
LAD ← 1;
DO BEGIN "BRA"
LN ← LVER[L];
LIN ← (L+1)% 2;
CRE ← LCREDE[LIN] LAND '400000007777;
IF ¬(LNCRE1≤CRE≤LNCRE2) THEN
BEGIN "BRB"
IF ¬FLAGS[LIN]∧CRE<1000 THEN LNKFLG← TRUE;
MSCVCO(-L,CV,0);
MSCVCO(L,-NCV,LAD);
LAD ← LAD+1;
IF LAD=2 THEN NCV←LVERCO[L];
FLAGS[LIN] ← TRUE;
END "BRB";
L ← LN;
N ← N-1;
END "BRA" UNTIL ¬N;
END "BREAK";
_ CLUPSC;
_ Cleans up the scene after the isolation of a complete or a best partial,
i.e. removes (to LCREDE=3000+CURMAP) all unused lines coinciding with
or contained within any line of the object. Lines of other objects
linked to common cv's are unlinked and given new cv's;
PROCEDURE CLUPSC(SAFEX INTEGER ARRAY FLAGS);
BEGIN "CLUPSC" INTEGER IA,IB,IC,IV2,IV1, LV, M, N1;
REAL RL,X1,X2,DIFX,DIFY,Y1,Y2;
SAFEX INTEGER ARRAY MP[1:MAXNOV];
DEFINE BK(CV)="IF ¬MP[CV] THEN BEGIN BREAK(CV,FLAGS);MP[CV]←1;END",
RESET="LNCRE1←LNCS1; LNCRE2←LNCS2";
MP[1] ← 0;
ARRBLT(MP[2],MP[1],MAXNOV-1);
N1←2000+2*CURMAP;
RWIC←2.0*RWIC;
M ← N1-1;
LOOP(IA,1,MAXNOL,1) IF M≤LCRL(IA)≤N1 THEN
BEGIN "CLA"
LNCRE2←N1;
LNCRE1←LNCRE2-1;
IB←2*IA;
IV1←LVERCO[IB-1];
X1←XVCOR[IV1];
Y1←YVCOR[IV1];
BK(IV1);
IV1←LVERCO[IB];
X2←XVCOR[IV1];
Y2←YVCOR[IV1];
BK(IV1);
RL←RLEN[IA];
DIFX←RWIC*(X1-X2)/RL;
DIFY←RWIC*(Y1-Y2)/RL;
REKOP(X1+DIFX,Y1+DIFY,X2-DIFX,Y2-DIFY,RWIC,RL);
RESET;
LOOP(IB,1,MAXNOL,1) IF LNCRE1≤(LCREDE[IB] LAND '400000007777)
≤LNCRE2∧ANGLIN(IA,IB)<RMAP THEN
BEGIN "CLC"
IC←2*IB;
IV1←LVERCO[IC-1];
IV2←LVERCO[IC];
IF INREK(XVCOR[IV1],YVCOR[IV1])∧INREK(XVCOR[IV2],
YVCOR[IV2]) THEN
BEGIN "CLB"
LNCRE1←LNCRE2←3000+CURMAP;
MLCR(IB,LNCRE1);
BK(IV2);
BK(IV1);
RESET;
END "CLB";
END "CLC";
END "CLA";
_ CLUPSC cont;
LNCRE2←N1;
LNCRE1←LNCRE2-1;
LOOP(IA,1,MAXNOV,1) IF ¬MP[IA]∧BELCRE(IA) THEN
WEIGHV(IA,XVCOR[IA],YVCOR[IA],RL);
RESET;
RWIC←RWIC/2.0
END "CLUPSC";
_ FUSABL;
_ Returns -1 (else 0) iff L2>0 and lines of s.v:s V1 and V2 are collinear.
If L2≤0, we check whether line of s.v. L1 may be extended through V1
(if L2=0) or V2 (if L2=-1).;
INTERNAL INTEGER PROCEDURE FUSABL(INTEGER L1,L2,V1,V2);
BEGIN "FUSABL"
SHORT INTEGER N1, IL1, IL2, IRET, CV;
SHORT REAL DIST, TEST, CV1, CV2, CX, CY;
RECURSIVE BOOLEAN PROCEDURE CHECK(INTEGER V1, VN);
BEGIN INTEGER V2;
V2 ← ABS LINK[V1];
IF ¬V2 THEN RETURN(FALSE);
RETURN(V2=VN∨CHECK(LVOPP(V2),VN));
END;
IRET ← DIST ← TEST ← 0;
IF L2>0∧(CHECK(V1,V2)∨CHECK(V2,V1)) THEN IRET ← -1;
IL1←(L1+1)%2;
IF L2≤0 THEN
BEGIN
N1←CASE -L2 OF(V1,V2);
CV1 ← XVCOR[N1];
CV2 ← YVCOR[N1];
CV ← LVERCO[L1];
CX ← CXL[IL1];
CY ← CYL[IL1];
DIST←ABS(CX*CV1+CY*CV2+CCL[IL1])/SQRT(CX↑2+CY↑2);
TEST←SQRT((CV1-XVCOR[CV])↑2+(CV2-YVCOR[CV])↑2)*0.1+0.1;
END;
IF TEST THEN IRET ← DIST≤TEST ELSE IF ¬IRET THEN
BEGIN
IL1←LVOPP(V1);
IL2←LVOPP(V2);
IRET ← KARN(XLCOR[V1],YLCOR[V1],XLCOR[IL1]
,YLCOR[IL1],XLCOR[V2],YLCOR[V2],XLCOR[IL2]
,YLCOR[IL2],-1)=-1;
END;
DTRC("FUSABL: "QC(L1)QC(L2)QC(V1)QC(V2)QCR(DIST)QCR(TEST)QC(IRET));
RETURN(IRET);
END "FUSABL";
_ LFDIF;
_ Returns encoded actions to be performed at end ND2 of LF2 in order to
make it similar to end ND1 of LF1. If TST, other ends must agree (otherwise
error-return = '400). The program also sets the sequential modification
word (MODIF). MODIF contains two bits for each line-position at ND2 of
LF2, telling what to do at that position:
{(0 = no change)(1 = insert line here)(2 = delete line here)
(3 unused code)}.
MODIF←-1 if there is no unambiguous modification possible.
MODIF has its high bit turned on iff end single before insertions.
The program pays no attention to the outer angle at ND2 of LF2.;
INTERNAL SIMPLE INTEGER PROCEDURE LFDIF(INTEGER LF1,LF2,ND1,ND2,TST);
BEGIN "LFDIF"
INTEGER C1,C2,N1,N2,NLDIF,PAR,IA,IB,DEL,CH,IRET,INS,D1,D2,IPD,
DS1,DS2,CHAR,POS1,POS2,INSTOT,NTOT,BARAM;
_ DN is displacement for other ends. DSN originally points to
"#lines>180", later to "#lines≤180". CN = constellation bits.
CH=INS∨DEL all refer to first or last line respectively.;
LABEL OU;
DS1←31-(D1←18*ND1);
DS2←31-(D2←18*ND2);
MDCTR←IRET←INSTOT←NTOT←BARAM←0;
MODIF←2;
RAYS←BITS(LF1,DS1,DS1+3);
IF TST∧((LF1 LSH (-D1)) XOR (LF2 LSH (-D2))) LAND '367500 THEN
BEGIN MODIF←-1; IRET←'400; GO OU END;
_ The other ends are in agreement.;
LOOP(IA,1,2,1)
BEGIN
C1←BITS(LF1,3+D1,4+D1);
C2←BITS(LF2,3+D2,4+D2);
INS←(C2=2∧(C1 LAND 1)∨C2∧¬C1);
CH←-((DEL←C1∧¬C2∨C1=2∧(C2 LAND 1))∨INS);
PAR←C1 LAND 1;
IPD←INS∨PAR∧¬DEL;
IRET←((IRET LSH 1 LOR CH) LSH 1 LOR (-DEL)) LSH 1 LOR PAR;
NLDIF←(N1←BITS(LF1,DS1,DS1+3))-
(N2←BITS(LF2,DS2,DS2+3))+INS-DEL;
IRET←( ( ( (IRET LSH 1 LOR(-(NLDIF<0)))
LSH 4 LOR ABS NLDIF)
LSH 4 LOR (POS1←IF IA=2 THEN 1 ELSE
IF IPD THEN 2 ELSE 1))
LSH 4 LOR (POS2←(IF NLDIF≥0 THEN N1 ELSE N2-INS+DEL)
+(IA=2∧IPD)))
LSH 2 LOR (CHAR←IF ¬CH∧¬NLDIF THEN -(N1>0) ELSE
IF ¬NLDIF THEN 2 ELSE
IF ABS NLDIF=POS2-POS1+1 THEN 2 ELSE
(BARAM←2)+1);
IF CHAR<2 THEN MODIF←MODIF LSH (2*N1) ELSE
BEGIN
IF IA=1∧(CH∨PAR) THEN
MODIF←MODIF LSH 2 LOR (-INS-2*DEL);
N2←IF NLDIF<0 THEN N2+(DEL∨PAR∧¬INS) ELSE N1+IPD;
LOOP(IB,1,N2,1)
MODIF←MODIF LSH 2 LOR
(IF CHAR=3 THEN 3 ELSE
IF NLDIF>0 THEN 1 ELSE
IF ¬NLDIF THEN 0 ELSE 2);
IF IA=2∧(CH∨PAR) THEN
MODIF←MODIF LSH 2 LOR (-INS-2*DEL)
END;
D1←18-D1;
D2←18-D2;
DS1←DS1-5;
DS2←DS2-5;
INSTOT←INSTOT-INS+(0 MAX NLDIF);
NTOT←NTOT+N1
END;
START_CODE LABEL L1, L2;
SKIPG 1,MODIF;
JRST L2;
MOVE 2,MDCTR;
L1: LSH 1,2;
ADDI 2,2;
JUMPG 1,L1;
MOVEM 2,MDCTR;
MOVEM 1,MODIF;
L2: END;
MODIF←(MODIF LAND '177777777777) LOR ((BARAM-(INSTOT=NTOT)) LSH 34);
OU: DTRC("LFDIF: "QCO(LF1)QCO(LF2)QC(ND1)QC(ND2)QCO(IRET)QCO(MODIF));
RETURN(IRET)
END "LFDIF";
_ GARCOL;
_ This is the garbage collector for the PARTS free storage array.
CMPIND and BSTBYT will be adjusted if they pointed to used blocks.
FREE is the minimum number of free words needed. Free core retreived
will be cleared. FRECOR is size of PARTS. DELFLG is true if some
blocks have been deleted. If FLAG is FALSE, garbage collect PARTS for
more space. If FLAG is TRUE, garbage collect to retreive free lines.
If all else fails, delete lowest 2 scores. Assume free core too small
on entry ;
INTERNAL PROCEDURE GARCOL(INTEGER FREE; BOOLEAN FLAG);
BEGIN "GARCOL" LABEL PACK, DELET;
INTEGER BEST,OLD,NEW,LENG,LOW,LOWER,BYTE,PTL,PTLR,SCOR,BT,INCNT,
ICNT,BTT,I,J,OCNT,DEL;
EXTERNAL SAFEX INTEGER ARRAY PARTS[1:FRECOR];
SIMPLE PROCEDURE DELBLK(INTEGER BY);
BEGIN "DELBLK"
IBP(BY);
ICNT ← ILDB(BY);
BY ← BY+1;
IDPB(1,BY);
BY ← BY+1;
FOR I←1 STEP 1 UNTIL ICNT DO IF LCRL(J←ILDB(BY))=1004
THEN BEGIN LINDL(J,0);INCNT←INCNT+1;END;
END "DELBLK";
_ If DELFLG set, pack blocks still in use;
OUTSTR("GARBAGE COLLECTOR CALLED-"&
(IF FLAG THEN "LINES" ELSE "MAPPINGS")&CL);
DTRC("GARBAGE COLLECTOR CALLED-"&
(IF FLAG THEN "LINES" ELSE "MAPPINGS")&CL);
OCNT ← INCNT←0;
IF ¬DELFLG∨FLAG THEN GO TO DELET;
PACK: OLD ← NEW ← 1;
BEST ← (BSTBYT LAND '777777)-LOCATION(PARTS[1]);
DEL ← 0;
DO BEGIN "PACK"
LENG ← PARTS[OLD] LSH -24;
IF (BEST=OLD)∨¬PARTS[OLD+1] LAND 1 THEN
BEGIN "SAVE"
IF OLD≠NEW THEN
BEGIN "MOVE"
ARRBLT(PARTS[NEW],PARTS[OLD],LENG);
IF CMPIND=OLD THEN CMPIND← NEW;
IF BEST=OLD THEN BSTBYT←(BSTBYT LAND '777777000000) LOR
(NEW+LOCATION(PARTS[1]));
END "MOVE";
NEW ← NEW+LENG;
END "SAVE" ELSE DEL ← DEL+1;
_ GARCOL cont;
OLD ← OLD+LENG;
END "PACK" UNTIL OLD>FRECOR∨¬PARTS[OLD];
IF CMPIND≥OLD THEN CMPIND ← NEW;
DELFLG ← FALSE;
PARTS[NEW] ← 0;
ARRBLT(PARTS[NEW+1],PARTS[NEW],FRECOR-NEW);
_ if we recovered enough core, return;
OUTSTR(CVS(DEL)&" BLOCKS DELETED"&CL);
DTRC(CVS(DEL)&" BLOCKS DELETED"&CL);
IF FREE≤(IF FLAG THEN INCNT ELSE FRECOR-NEW+1) THEN RETURN;
IF FLAG∧INCNT=OCNT∨¬FLAG∧NEW=OLD THEN
BEGIN "GARN"
OUTSTR("INSUFFICIENT FREE SPACE"&CL);
RETURN;
END "GARN";
_ find and delete blocks with two lowest scores
if looking for lines, delete only those with inserted lines;
OCNT ← INCNT;
DELET:
LOW ← LOWER ← 1000;
OLD ← 1;
BYTE ← POINT(12,PARTS[1],-1);
DO BEGIN "FIND" LABEL NXT;
BT ← BYTE;
LENG ← ILDB(BT);
BTT ← BT+1;
ICNT ← ILDB(BT);
SCOR ← ILDB(BTT);
IF FLAG THEN
BEGIN "FNDLIN"
BTT ← BYTE+3;
FOR I←1 STEP 1 UNTIL ICNT DO IF LCRL(ILDB(BTT))
=1004 THEN DONE;
IF I>ICNT THEN GO TO NXT;
END "FNDLIN";
IF SCOR<LOWER THEN
BEGIN LOW←LOWER;LOWER←SCOR;PTL←PTLR;PTLR←BYTE;END ELSE
IF SCOR<LOW THEN
BEGIN LOW←SCOR; PTL ← BYTE; END;
NXT: BYTE ← BYTE+LENG;
OLD ← OLD+LENG;
END "FIND" UNTIL OLD>FRECOR∨¬PARTS[OLD];
DELBLK(PTLR);
DELBLK(PTL);
GO TO PACK;
END "GARCOL";
_ MAP (VCRKEY);
_ Sets up the expanded parallel datastructure for prototype PROT.
Then initializes mapping arrays according to the basic mapping
provided by the key feature FEAT (c.f. or l.f.) from the scene
into the prototype. Then calls MAPREC to complete the mapping,
described in PLMAP (scene-line corresponding to prot.-line)
and in PVMAP (scene-vertex corresponding to prot.-vertex).;
INTERNAL INTEGER PROCEDURE MAP(INTEGER LSC,LPR,DIR);
BEGIN "MAP"
INTEGER IA,PLNE,SHFT,IB,KEY;
SAFEX EXTERNAL INTEGER ARRAY LENDV,LENDP,LLEV,LLEVO,PLMAP,
LFUSE,PLMAPO[1:MAXPLS,0:1],MAPORD,PARCLA,LENCAT,INSLEV,
DEADLN,LFTSTL[1:MAXPLS],VLEV,FLMAPS,PVMAP[1:MAXPVS],
PARTS[1:FRECOR];
SAFEX EXTERNAL REAL ARRAY PARARG[0:MAXPLS],LENARG[0:MAXPLS,0:1,0:1];
_ Returns 1 (else 0) iff present key is unexplored (virgin).;
SIMPLE INTEGER PROCEDURE VIRKEY;
BEGIN "VIRKEY"
INTEGER IA;
KEY←((LSC LSH 12 LOR PROT) LSH 12 LOR LPR) LSH 1 LOR DIR;
LOOP(IA,1,FLMIND,1) IF FLMAPS[IA]=KEY THEN RETURN(0);
FLMIND←FLMIND+1;
FLMAPS[FLMIND]←KEY;
RETURN(1)
END "VIRKEY";
SQTRC(CL&"PROT= "&CVS(PROT)&" LPR= "&CVS(LPR)&" LSC= "&CVS(LSC)&
" DIR= "&CVOS(DIR)&CL);
LFDBT←(DIR LSH -1) LAND 1 XOR (DIR←DIR LAND 1);
IF ¬LACT(LSC)∨¬VIRKEY THEN
BEGIN "MAPA"
QTRC(CL&"Key not virgin"&CL);
RETURN(-1)
END "MAPA";
IF MAPTRC LAND '20000 THEN
BEGIN "MAPB"
OUTSTR("NEW KEY - MAPTRC? ");
IF INCHRW="←" THEN MAPTRC←MAPCONV(INSTR(":"));
OUTSTR(CL)
END "MAPB";
_ MAP cont;
_ First set up expanded prototype datastructure,
and zero line-mapping arrays.;
LOOP(IA,1,PLIN,1)
BEGIN "MAPC"
PLNE←PLINE[AD0+IA];
PARCLA[IA]←PLNE LAND '37;
LENCAT[IA]←PLINE2[AD0+IA] LSH -9 LAND 1;
LOOP(IB,0,1,1)
BEGIN "MAPD"
SHFT ← 6*IB;
LENDV[IA,IB]←BITS(PLNE,30-SHFT,35-SHFT);
LENDP[IA,IB]←BITS(PLNE,18-SHFT,23-SHFT)
END "MAPD";
END "MAPC";
PARARG[0] ← -1.0;
ARRBLT(PARARG[1],PARARG[0],MAXPLS);
LEDG1[1]←PVMAP[1]←LENARG[0,0,0]←INSLEV[1]←PLMAP[1,0]←0;
ARRBLT(LEDG1[2],LEDG1[1],MAXNOL-1);
ARRTRAN(LEDG2,LEDG1);
ARRBLT(INSLEV[2],INSLEV[1],MAXPLS-1);
ARRTRAN(LFTSTL,INSLEV);
ARRTRAN(DEADLN,INSLEV);
ARRBLT(PLMAP[1,1],PLMAP[1,0],MAXPLS*2-1);
ARRTRAN(LFUSE,PLMAP);
ARRTRAN(LLEV,PLMAP);
ARRBLT(PVMAP[2],PVMAP[1],MAXPVS-1);
ARRTRAN(VLEV,PVMAP);
ARRBLT(LENARG[0,0,1],LENARG[0,0,0],(MAXPLS+1)*4-1);
_ Initialize the mapping (1 line) and call on MAPREC to do the job.;
MAPORD[1]←LPR;
MLCR(LSC,1001);
PLMAP[LPR,1-LFDBT]←2*LSC-(DIR XOR LFDBT);
LEDG1[LSC] ← '201;
LLEV[LPR,1-LFDBT]←1;
PARTS[CMPIND+2]←KEY;
DPB(PROT,BYT1+1);
KMP←1;
RETURN(MAPREC)
END "MAP";
_ CLEANUP;
_ Remove replaced lines and delete overlapped mappings;
PROCEDURE CLEANUP;
BEGIN "CLEANUP" SAFEX INTEGER ARRAY FLAGS[1:MAXNOL];
EXTERNAL SAFEX INTEGER ARRAY PARTS[1:FRECOR], FLMAPS[1:MAXPVS];
INTEGER BT, CNT, I, LENG, SCOR, OLD, BTA, RCNT, J;
_ first flag lines in mapping and remove and flag replaced lines;
BT ← BYTE+3;
CNT ← LDB(BYT2)+LDB(BYT3);
FOR I←1 STEP 1 UNTIL CNT DO FLAGS[ILDB(BT)] ← TRUE;
LNKFLG ← FALSE;
CLUPSC(FLAGS);
_ now delete removed mapping and all those which overlap it.
Put keys for others back in FLMAPS and find next best score;
OLD ← (BYTE LAND '777777)-LOCATION(PARTS[1])+1;
BSTBYT ← FLMIND ← SCOR ← 0;
CMPIND ← DELFLG ← 1;
SETBYTE(1);
BYTE ← BYTE+3;
DO BEGIN "DELETE" LABEL DEL, UPD;
LENG ← LDB(BYT1);
RCNT ← LDB(BYT2);
BTA ← BT ← BYTE;
I ← LDB(BYT3+1);
IF I LAND 1 THEN GO TO UPD;
IF CMPIND = OLD∨I LAND 4 THEN GO TO DEL;
CNT ← RCNT+LDB(BYT3);
FOR I←1 STEP 1 UNTIL CNT DO IF FLAGS[ILDB(BT)] THEN
DEL: BEGIN "DEL"
DPB(1,BYT3+1);
FOR I←1 STEP 1 UNTIL RCNT DO IF LCRL(J←ILDB(BTA))
=1004 THEN LINDL(J,0);
GO TO UPD;
END "DEL";
FLMIND ← FLMIND+1;
FLMAPS[FLMIND] ← PARTS[CMPIND+2];
I ← LDB(BYT2+1);
IF I>SCOR THEN BEGIN SCOR←I; BSTBYT←BYT2+1; END;
UPD: BYT1 ← BYT1+LENG;
BYT2 ← BYT2+LENG;
BYT3 ← BYT3+LENG;
BYTE ← BYTE+LENG;
CMPIND ← CMPIND+LENG;
END "DELETE" UNTIL ¬PARTS[CMPIND];
IF CMPIND-LENG=1 THEN BEGIN CMPIND←1; ARRCLR(PARTS,0); END;
END "CLEANUP";
_ PARSE;
_ Will attempt to find a satisfactory parsing of the scene. Note that the
PARTS-storage implementation limits the number of lines to 511.;
INTERNAL PROCEDURE PARSE;
BEGIN "PARSE"
LABEL ITER,REP,REV,ISO,BA1,EXH;
SAFEX INTERNAL REAL ARRAY LENARG[0:MAXPLS,0:1,0:1],PARARG[0:MAXPLS];
SAFEX INTERNAL INTEGER ARRAY MPORDS,MAPIS[1:2*MAXPLS],LENDV,LENDP,
LLEV,LLEVO,PLMAP,LFUSE,PLMAPO[1:MAXPLS,0:1],MAPORD,PARCLA,
DEADLN,LENCAT,INSLEV,EVA,LFTSTL[1:MAXPLS],VLEV,
PVMAP[1:MAXPVS],PARTS[1:FRECOR],FLMAPS[1:MAXNOV];
INTEGER MAXCOM,IA,IB,KADR,PFP,CFP,PRP,SCL1,SCL2,PRL1,PRL2,N1,
LB,UB,FTI,UBI,DIR,IBB,ICC,
ORD,SUCC,IC,ID,MXMXCM,I1,I2,I3,REVER,PARTSI;
FRESIZE ← FRECOR;
LNCRE0←LNCS1←LNCRE1;
LNCS2←LNCRE2;
IF MAPTRC=-1 THEN
BEGIN "PARA"
MAPTRC←0;
LOOP(IA,1,MAXNOL,1)
BEGIN "PARB"
WHILE (IB←LCRL(IA))>2000 DO REVIVE(IA);
IF IB=1001 THEN REVIVE(IA) ELSE
IF IB≥1002∧IB≤1005 THEN LINDL(IA,0)
END "PARB";
UNXREF;
UPPDAL(0);
RETURN
END "PARA";
CURMAP ← TC ← DELFLG ← BSTBYT ← FLMIND ← 0;
CMPIND ← 1;
DTRACE←MAPTRC LAND '10000;
DCHAN←NPRS←-1;
QTRC(CL&"PARSER RESULTS:"&CL);
LNKFLG ← TRUE;
_ PARSE cont;
_ Initialize PFPTR.;
REP: LB←PLFTOT+1;
UB←PFTOT;
UBI←1;
FTSW←0;
SETBYTE(CMPIND);
QTRC("CF-keys"&CL);
IF LNKFLG THEN XREFC(0);
FTEX;
_ Display scene?;
IF MAPTRC LAND '1000000 THEN
BEGIN "PARC"
DISW ← TRUE;
OUTSTR(CL&"SCENE");
UPPDAL(MAPTRC LAND '2000000)
END "PARC";
LOOP(IA,1,PFTOT,1) PFPTR[IA]←PFPTR[IA] LAND '377777777777;
_ Find un-exhausted key of maximum complexity.;
MXMXCM←0;
CURMAP←CURMAP+1;
ITER: MAXCOM←KMP←SUCC←0;
LOOP(IA,UB,LB,-1) IF MAXCOM<PFPTR[IA] THEN
BEGIN "PARD"
MAXCOM←PFPTR[KADR←IA];
IF MAXCOM=MXMXCM THEN DONE;
END "PARD";
IF ¬MAXCOM THEN GO ISO;
MXMXCM←MAXCOM;
_ Now exhaust the mappings where this feature serves as the key.;
IC←PFPTR[KADR];
CFP←BITS(IC,12,23);
ORD←IC LAND '4000000000;
DTRC(" "QC(KADR)QC(CFP)QCO(ORD));
_ PARSE cont;
_ If L.F., find a line with this feature to start mapping;
LOOP(FTI,1,UBI,1)
IF ¬FTSW∨LNCRE1≤LCREDE[FTI] LAND '400000007777≤LNCRE2
∧((IB←LFEAT[FTI])<0∧FTSW=2∨IB>0∧FTSW=1)
∧KADR=IB LAND '7777 THEN
_ Check each instance of feature in scene;
WHILE (CFP←CFP+FTSW) DO
BEGIN "CFPL"
SCL1←IF FTSW THEN FTI ELSE BITS(IC←CFEAT[CFP],24,34);
IF ¬FTSW THEN SCL2←BITS(IC,12,22);
PRP←PFPTR[KADR] LAND '7777;
_ against each prototype containing the feature;
WHILE PRP DO
BEGIN "PRPL"
PROT←BITS(PFPRO[PRP],24,35);
AD0←PPTRL[PROT]-1;
PLIN←PLINES[PROT];
PVER←PVERTS[PROT];
PFP←BITS(PFPRO[PRP],12,23)+1;
_ and each instance for that prototype;
WHILE PFP>1 DO
BEGIN "PFPL"
IB←PFEAT[PFP];
PRL2←PRL1←BITS(IB,24,33);
IF ¬FTSW THEN PRL2←BITS(IB,12,21);
QTRC(CL&"FEAT: "&CVS(KADR)&" SC-LNS: "&
CVS(SCL1)&BL&CVS(SCL2)&
" PROT: "&CVS(PROT)&" PR-LNS: "&
CVS(PRL1)&BL&CVS(PRL2)&CL);
DIR←IF FTSW THEN LFEAT[FTI] LSH -33 ELSE
BITS(IB,34,34) XOR (ID←BITS(IC,35,35));
SUCC←MAP(SCL1,PRL1,DIR);
REVER←0;
_ PARSE cont.;
_ Check results of mapping;
BA1: IF SUCC≥0∧MAPTRC LAND '100 THEN
BEGIN
INTEGER BYTA, BYTB, CNT;
BYTA ← BYTB ← BYTE+3;
CNT ← LDB(BYT2);
OUTSTR(CL&"BEST(MAP) - PROT: "&
PNAME[PROT]QSCOR&CL);
LNCRE0←LNCRE2←1006;
LOOP(I1,1,CNT,1)
MLCR(ILDB(BYTB),1006);
UPPDAL(MAPTRC LAND '200);
LNCRE0←LNCS1;
LNCRE2←LNCS2;
LOOP(I1,1,CNT,1)
REVIVE(ILDB(BYTA));
END;
CASE SUCC+1 OF BEGIN GO REV;;GO ISO;END;
_ We have here a maximal partial mapping for
this key. See if it is a maximal partial
for this iteration of PARSE. Also init
data structure for next mapping. ;
IF ¬BSTBYT∨LDB(BYT2+1)>LDB(BSTBYT) THEN
BEGIN
BSTBYT←BYT2+1;
QTRC(CL&"New best partial"&CL)
END;
CMPIND ← LDB(BYT1)+CMPIND;
IF CMPIND+2>FRESIZE THEN GARCOL(3,FALSE);
SETBYTE(CMPIND);
_ If feature is ordered, try other direction;
REV: PARTS[CMPIND]←PARTS[CMPIND+1] ← 0;
IF ¬REVER∧ORD THEN
BEGIN
SUCC←MAP(SCL1,PRL2,IF FTSW THEN 1-DIR
ELSE BITS(IB,22,22) XOR ID);
REVER←1;
GO BA1
END;
_ PARSE cont;
_ Display scene?;
IF SUCC+1∧KMP∧MAPTRC LAND '200000 THEN
BEGIN
OUTSTR(CL&"SCENE");
UPPDAL(MAPTRC LAND '400000)
END;
_ Parsing process continues normally with next
key ( = scene-line(s) & prototype &
prototype-line(s) combination).;
PFP←PFEAT[PFP] LAND '7777
END "PFPL";
PRP←PFPRO[PRP] LAND '7777
END "PRPL";
CFP←IF FTSW THEN -FTSW ELSE CFEAT[CFP] LAND '7777;
END "CFPL";
_ Iterate at this point, starting by finding the best
unused key-feature at this stage.;
PFPTR[KADR]←PFPTR[KADR] LOR '400000000000;
GO ITER;
_ Use l.f. keys as well, before deciding on mapping.;
ISO: IF SUCC<1∧FTSW<2 THEN
BEGIN
FTSW←FTSW+1;
LB←1;
UB←PLFTOT;
UBI←MAXNOL;
SCL2←PRL2←MXMXCM←0;
IF FTSW=2 THEN LOOP(IA,1,PLFTOT,1) PFPTR[IA]←
PFPTR[IA] LAND '377777777777;
QTRC((CASE FTSW OF("L","L","P"))&"F-keys"&CL);
GO ITER
END;
_ Isolation of partial (or complete) object.;
_ First check if the parsing process is at an end.;
IF ¬BSTBYT∧SUCC≠1 THEN
EXH: BEGIN
SQTRC(CL&"SCENE EXHAUST ED - END OF PARSE"&CL);
MAPTRC←0;
IF DTRACE THEN BEGIN CLOSE(DCHAN); DCHAN←-1;END;
RETURN
END;
_ PARSE cont;
_ Now truck object off to LCREDE=2000+2*CURMAP.;
IF ¬LDB(BYT3+1) LAND 2 THEN SETBYTE((BSTBYT LAND '777777)
-LOCATION(PARTS[1]));
IC←2000+2*CURMAP;
N1←LDB(BYT1+1);
I2←LDB(BYT2);
IB←BYTE+3;
LB ← FALSE;
LOOP(I1,1,I2,1)
BEGIN
I3←ILDB(IB);
UB ← LCRL(I3)≠1004;
MLCR(I3,IC+UB);
IF ¬UB THEN LB ← TRUE;
END;
IA←IB←BYTE+3;
IF MAPTRC LAND '400 THEN
BEGIN
OUTSTR(CL&"BEST(PARSE) - PROT: "&PNAME[N1]&CL);
LNCRE0←LNCRE2←1006;
LOOP(I1,1,I2,1) MLCR(ILDB(IB),1006);
UPPDAL(MAPTRC LAND '1000);
LNCRE0←LNCS1;
LNCRE2←LNCS2;
LOOP(I1,1,I2,1) REVIVE(ILDB(IA))
END;
_ Finally clean up the scene, shipping all replaced lines
(partial lines belonging to the object but superceded as members
of the mapping) into oblivion at LCREDE=3000+CURMAP and delete
mappings which overlap removed mapping;
N1 ← LNKFLG∧¬LDB(BYT3+1) LAND 2;
CLEANUP;
IF LB∧N1 THEN
BEGIN
LNCRE1←IC-1;
LNCRE2←IC;
UNXREF;
XREFC(0);
LNCRE1←LNCS1;
LNCRE2←LNCS2;
END;
_ PARSE cont;
_ Now the scene may have changed in some relevant way, so before
going through a renewed cross-reference investigation and
feature-extraction, and continuing the parse, we perform an
UNXREF to detach topologically all removed or transferred lines.;
IF MAPTRC LAND '4000000 THEN
BEGIN
LNCRE1←1;
LNCRE2←4000;
REGREF(11);
LNCRE1←LNCS1;
LNCRE2←LNCS2;
END;
IF LNKFLG THEN
BEGIN "UNL"
LNCRE2 ← 2000;
UNXREF;
LNCRE2 ← LNCS2;
END "UNL";
_ Also make sure we have some active lines left to work on;
I2 ← 0;
LOOP(I1,1,MAXNOL,1) IF LNCRE1≤LCREDE[I1] LAND '400000007777≤LNCRE2
THEN I2←I2+1;
IF I2<3 THEN GO EXH ELSE GO REP;
END "PARSE";
END "MAPS1";